perm filename FM.SAI[X,ALS] blob
sn#810385 filedate 1986-02-14 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00040 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00005 00002 BEGIN "FM"
C00008 00003 ! Macros
C00010 00004 help strings
C00013 00005 simple proc esc_I
C00014 00006 ! USER HELP H,? commands, etc : HELPHIM
C00015 00007 ! Initialization
C00017 00008 ! Asking for a value change: ASKABOUT
C00018 00009 ! UTILITY FUNCTIONS: octscan
C00019 00010 ! Get a character list from TTY: CHARSCAN
C00021 00011 ! Returns how big the last file opened is
C00022 00012 ! Parsing a file name string
C00024 00013 ! Try to get me a file TRYTOGET
C00025 00014 ! Get me a file: GETMEONEOF
C00029 00015 ! (Garbage collection) GETTEMPS
C00030 00016 ! Put a font on a channel: PUTFONTX
C00034 00017 ! GARBAGECOLLECT
C00036 00018 ! Allocation of memory space
C00037 00019 ! Deleting or creating a fontable
C00038 00020 ! FONT FILE TO PIXEL CONVERSION the G command
C00040 00021 ! PIXEL TO FONT CONVERSION. The P command PUTFONT
C00041 00022 ! Procedures STOW and STASH that are used by the M command
C00043 00023 ! PIXEL to GF CONVERSION: the M (Make GF) command. FNT_2_GF
C00056 00024 ! PIXEL TO GF FONT CONVERSION. The M command WRITEGF
C00060 00025 ! Assignment
C00062 00026 ! The Assign (A) command
C00064 00027 ! The I command
C00066 00028 ! PIXEL to STARS CONVERSION: the W command
C00070 00029 ! Writestar: the W command
C00075 00030 ! PIXEL to Z_STARS CONVERSION: the Z command
C00089 00031 ! Z_Writestar: the Z command
C00094 00032 ! PIXEL to N_STARS CONVERSION: the N command
C00110 00033 ! N_Writestar: the N command
C00115 00034 ! Set up directory table: SELECTDIRECT
C00118 00035 ! Stars to PIXELS: the R command, STARS2LINES
C00131 00036 ! Change the font's characteristics -- the F command
C00133 00037 ! Play with characters - the C command: CHAREDIT
C00136 00038 ! save the state of the computation: SAVETHEWORLD
C00139 00039 INTEGER PROC THEWORLD(INTEGER MEMSIZE)
C00145 00040 ! Main program!
C00146 ENDMK
C⊗;
BEGIN "FM"
define DEBUG = 0 ;
REQUIRE "SMAC.SAI[x,als]" SOURCE!FILE;
NEEDDISPLAY;
STRING TTYIN; ! INPUT FROM TTY;
INTEGER ARRAY FT[-1:2]; ! Pointers into M;
INTEGER TOP; ! The next free spot in M;
INTEGER WILLNEEDMANY; ! How many words will we need in the end?;
INTEGER STAR,DOT;
integer array rwhichchars[-1:'177]; ! Saved for Readstar;
integer rchan,howfew,selectans; ! Saved for readstar;
integer rcnt,rbrk,reof; ! Saved for readstar;
INTEGER GFW; ! GF word saved for STOW;
INTEGER BYTE_COUNT,WORD_COUNT; ! Saved for STOW;
INTEGER DIRW; ! DIR word saved for STASH;
INTEGER DIR_BYTE_COUNT,DIR_WORD_COUNT; ! Saved for STASH;
INTEGER MMIN_M,MMAX_M,MMIN_N,MMAX_N; ! SAVED FOR STOW;
integer array gfm[0:'7777]; ! Memory to hold gf data for the glyphs;
integer array gfdir[0:'777]; ! To hold the full gf font directory;
integer linebreak; ! Breaks on an input line;
external integer _skip_;
integer ALLSEEN; ! set by CHARSCAN if all characters requested;
integer worldmode; ! Which table was referenced by this command;
integer reenterer; ! When reentering THEWORLD, where to pick up;
integer restarter; ! When reentering THEWORLD, which to call;
INTEGER MSIZE; ! SIZE OF MAIN MEMORY;
integer Ifound;
integer mextra; ! How much to increment msize each time;
boolean escape_I; ! Has an escape_I been typed? ;
! Macros;
define pname(c) = ⊂ (if (c≥'16)then
(if c≤'174 then
(if c='40 then "#40" else
(if c='26 then "#26" else
(if c='73 then "#73" else
c&null)))
else
(if c='176 then c&null else ("#"&cvos(c))))
else
(if c≤'10 then (if c=0 then "#0" else c&null)
else ("#"&cvos(c)))) ⊃;
define fillimit = 50;
define fonthieght(fonty) = ⊂ M[FT[fonty]+'201] ⊃;
define fullnumb(n)= ⊂ (("0000"&cvs(n))[∞-4 to ∞]) ⊃;
define ERR = '777000000000;
comment help strings;
define mainhelp = ⊂
"FM, version 0.1 A revision of FMUNGE. Documentation on FMUNGE.REF[UP,DOC]
************** WELCOME to the wonderful world of font hacking *******************
COMMANDS:
G<fontname> Get the requested font. *
P<fontname> Put that font on <fontname>. *
I<fontname> Input a character from a font. *
R<filename> Read in a Star/Dot file, the requested characters. *
W<filename> Write Star/Dot file as requested (cr for all). *
N<filename> Write Star/Dot file scaled by 1.5/1. *
Z<filename> Write Star/Dot file scaled by 2/1. *
M<filename> Write out a GF file for the font. *
T Type Star/Dot image of the requested characters. *
A<char1>←<char2> Assign <char2> to <char1>
F Change the font characteristics. *
D Delete a font from memory. *
E Exit the program;
B Call Bail (if loaded).
H or ? Re-display this message.
S Save or restore the current memory structure.
C Character edit.
* ' and "" may be added to these commands
--------------------------------------------------------------------------------
"
⊃;
define charhelp = ⊂
"
Character editing commands are:
D Delete this character
K set the left Kern for this character.
W set this character's Width
Type <return> to pop to higher level.
--------------------------------------------------------------------------------
" ⊃ ;
simple proc esc_I;
escape_I ← 1;
define setescape = ⊂ begin escape_I←0;enable(15);end ⊃ ;
! USER HELP H,? commands, etc : HELPHIM;
simp proc helphim(boolean whichhelp(TRUE));
begin "hh"
cleardisplay;
if whichhelp then display(mainhelp) else display(charhelp);
end "hh";
! Initialization;
! forward simp INTEGER PROC GETMEONEOF(REFERENCE STRING TYPEDIN;
! STRING DEFAULT_EXT;
! REFERENCE INTEGER COUNT,BREAK,EOF;
! INTEGER MODE(0),IBUF(4),OBUF(0);
! BOOLEAN LOOKONXGPSYS(0);
! STRING DEVICE("DSK");
! INTEGER ERA(0));
simp proc init;
begin
integer tmp,append,who,when,chan,day,month,year;
string foo;
star← "*";
dot ← ".";
if datadisc then helphim;
mextra←5000;
msize←8000;
restarter ← 0;
linebreak ← getbreak;
setbreak(linebreak,lf,null,"IAF");
FT[0]←FT[1]←FT[2]←-1;
intmap(15,esc_I,0);
! record useage statistics;
! foo ← "fmunge.use[fnt,ref]";
! chan ← getmeoneof(foo,"use",tmp,tmp,tmp,0,4,4,0,"dsk",0);
! if chan ≥ 0 then
! begin "report"
! ugetf(tmp,chan,append);
! who ← call(0,"GETPPN");
! when ← call(0,"ACCTIM");
! day ← (when lsh -18) mod 31 + 1;
! month ← ((when lsh -18) div 31) mod 12 + 1;
! year ← ((when lsh -18) div 31) div 12 + 64;
!
! out(chan,"["&cvxstr(who)&"]"&tab&
! cvs(month)&"/"&cvs(day)&"/"&cvs(year)&tab&
! ("0"&cvs((when land '777777) div 3600))[∞-1 to ∞]&":"&
! ("0"&cvs((when land '777777) div 60 mod 60))[∞-1 to ∞]&crlf);
! release(chan);
! end "report";
end;
! Asking for a value change: ASKABOUT;
simp integer proc askabout(string massage;integer oldval);
begin "aa"
string took;
integer idull;
outstr(massage&":");
reload(cvs(oldval));
took←inchwl;
if took≠null then return(intscan(took,idull)) else return(oldval);
end "aa";
! UTILITY FUNCTIONS: octscan;
simp integer proc octscan(reference string otyp);
begin "os"
integer totl,ibun;
totl←0;
while digit(otyp) do totl←8*totl+lop(otyp)-"0";
return(totl);
end "os";
! Get a character list from TTY: CHARSCAN;
simp integer proc charscan(boolean array markme);
begin "ocs" ! Returns how many characters have been marked;
integer totel,ibun,ivseen,tmp;
string typ;
ivseen←0;
outstr("Characters? (<altmode> to abort.):");
typ ← inchwl;
if _skip_= altmode then return (-1);
if typ then allseen ← 0 else allseen ← 1; ! A global variable;
for ibun← 0 til '177 do MARKME[ibun]←allseen;
if allseen then return(128);
while typ≠null do
begin "eachch"
if typ≠"#" ∨length(typ)≤1 ∨ ¬digit(typ[2 for 1]) then totel←lop(typ)
else
begin
tmp ← lop(typ);
totel←octscan(typ);
if totel≥128 then
tpri(<"That's a funny number there, "&cvos(totel)>)
end;
if ¬markme[totel] then begin ivseen←ivseen+1;markme[totel]←1 end;
end "eachch";
return(ivseen);
end "ocs";
! Returns how big the last file opened is;
simp integer proc HOWBIG;
begin
own integer array finfo[0:5];
FILEINFO(finfo);
return(-1 * (finfo[3] ash -18));
end;
! Parsing a file name string;
simp STRING PROC FILENAMEPARSE(REFERENCE STRING FL,AFL;STRING DEFAULT_EXT;
INTEGER LOOKONXGPSYS);
! Parse the file name, breaking into name, extension, and pppn;
BEGIN "FNP"
INTEGER DOTPOINT,BRACKETPOINT,I;
STRING EXT,TYPEDIN;
TYPEDIN←FL;
DOTPOINT ← 0;
BRACKETPOINT ← LENGTH(TYPEDIN)+1;
for I ← 1 til LENGTH(TYPEDIN) do
if TYPEDIN[I for 1]="." then DOTPOINT ← I
else
if TYPEDIN[I for 1]="[" then BRACKETPOINT ← I;
if ¬DOTPOINT then begin EXT ← DEFAULT_EXT;DOTPOINT ← BRACKETPOINT end
else
EXT ← TYPEDIN[DOTPOINT+1 to BRACKETPOINT-1];
FL ←
TYPEDIN[1 to DOTPOINT-1]&"."&EXT&TYPEDIN[BRACKETPOINT to ∞];
IF LOOKONXGPSYS then
AFL← TYPEDIN[1 to DOTPOINT-1]&"."&EXT&"[XGP,SYS]"
ELSE
AFL←null;
END "FNP";
! Try to get me a file TRYTOGET;
simp INTEGER PROC TRYTOGET(STRING FL;INTEGER CHAN,ibuf,obuf,ERA);
BEGIN "ttg"
boolean wrong;
LABEL look,eralbl,failure,prelook;
wrong ← 0;
prelook:if era then goto ERALBL;
look: if ibuf then lookup(chan,fl,wrong);
if wrong then return(-1);
ERALBL: if obuf then enter(chan,fl,wrong);
if wrong then return(-1);
if era then
begin "enterandreadalter"
close(chan);
era ← 0;
goto look;
end "enterandreadalter";
! success! ;
return(chan);
end "ttg";
! Get me a file: GETMEONEOF;
simp INTEGER PROC GETMEONEOF(REFERENCE STRING TYPEDIN;STRING DEFAULT_EXT;
REFERENCE INTEGER COUNT,BREAK,EOF;
INTEGER MODE(0),IBUF(4),OBUF(0);
BOOLEAN LOOKONXGPSYS(0);
STRING DEVICE("DSK");INTEGER ERA(0));
BEGIN "GMOF"
string AFL;
INTEGER CHAN;
integer ans;
! Open the device;
CHAN ← GETCHAN;
if CHAN<0 THEN
begin;
tpri("Very strange -- we're out of i/o channels!");
return(-1);
end;
OPEN(CHAN,DEVICE,MODE,IBUF,OBUF,COUNT,BREAK,EOF);
if equ(device,"TTY") then return (chan);
if typedin=null then begin outstr("File?");typedin←inchwl;end;
while TRUE do
begin "looky"
if ¬typedin then begin release(chan);return(-1) end;
FILENAMEPARSE(typedin,afl,DEFAULT_EXT,LOOKONXGPSYS);
ans←trytoget(typedin,chan,ibuf,obuf,era);
! if equ(typedin,"fmunge.use[fnt,ref]") then return(ans);
if ans<0 ∧ afl then ans ← trytoget(afl,chan,ibuf,obuf,era);
if ans<0 then
begin "ohwhere"
outstr("Can't find file: "&typedin&
". Try again (<blank line to abort>)"&crlf&"File? ");
typedin ← inchwl;
end "ohwhere"
else
return(ans);
end "looky";
END "GMOF";
! (Garbage collection) GETTEMPS;
simp proc GETTEMPS(integer array M);
begin "gt"
integer eachfont,edum,isbig,echan;
string fileis;
top ← 0;
open(echan←getchan,"dsk",'10,19,0,edum,edum,edum);
for eachfont ← 0 til 2 do
if FT[eachfont]≥0 then
begin "fe"
lookup(echan,"$$tmp"&cvs(eachfont)&".fnt",edum);
isbig ← HOWBIG;
FT[eachfont]←top;
arryin(echan,M[top],isbig);
top←top+isbig;
rename(echan,null,0,edum);
close(echan);
end "fe";
release(echan);
end "gt";
! Put a font on a channel: PUTFONTX;
integer proc putfontx(integer array M;integer ochun,starton);
begin "pf"
! This procedure takes the font starting at STARTON, and
puts it out on channel OCHUN.;
integer placecount,atfirst;
integer ci,word1,longing,whereis,highest,myheight;
own integer array pointing[0:'177];
! ochun is the output channel. Placecount is the fictional
place in the file that the given character goes. CI is the character under
consideration. POINTING will form the new first block of the table;
useto(ochun,1); ! start output at beginning of file;
highest ← M[starton+'201];
placecount ← '400;
arryout(ochun,M[starton],'400); ! output table and font description;
! do the font;
for ci ← 0 til '177 do
begin "chair";
whereis ← ((M[starton+ci] lsh 18) ash -18) + starton;
if whereis=starton then
pointing[ci]←0
else
begin "outwithim"
longing ← M[whereis] land '777777;
myheight ←(M[whereis+1] land '777777) +
((M[whereis+1] lsh -18) land '777);
if myheight>highest then highest←myheight;
word1 ←
(if (M[whereis] lsh -27) = (M[starton+ci] lsh -18) then 0
else (M[whereis] land '777000000000)) lor
(ci lsh 18) lor
longing ;
wordout(ochun,word1);
arryout(ochun,M[whereis+1],longing-1);
pointing[ci]←(M[starton+ci] land '777777000000) lor placecount;
placecount ← placecount + longing;
end "outwithim";
end "chair";
useto(ochun,1);
arryout(ochun,pointing[0],128);
if highest>M[starton+'201] ∨ ¬M[starton+'203] then
begin "fixupp"
if highest>M[starton+'201] then
begin "fixheight"
tpri(<"Fixing font height to "&cvs(highest)>);
highest ↔ M[starton+'201];
end "fixheight";
if ¬M[starton+'203] then
M[starton+'203]←askabout(
"This font is 0 above the baseline. What should the value really be? ",0);
useto(ochun,2);
arryout(ochun,M[starton+'200],'200);
end "fixupp";
return(placecount); ! return the size of the font output;
end "pf";
! GARBAGECOLLECT;
integer proc GARBAGECOLLECT(integer array M;integer needhowmany);
begin "GC"
integer eachfont,echan,edum;
string fileis;
open(echan←getchan,"dsk",'10,2,19,edum,edum,edum);
willneedmany ← needhowmany;
for eachfont←0 til 2 do
if FT[eachfont]≥0 then
begin
enter(echan,"$$tmp"&cvs(eachfont)&".fnt",edum);
close(echan);
lookup(echan,"$$tmp"&cvs(eachfont)&".fnt",edum);
enter(echan,"$$tmp"&cvs(eachfont)&".fnt",edum);
willneedmany←willneedmany + putfontx(M,echan,ft[eachfont]);
close(echan);
end;
if willneedmany≥ MSIZE then return(-1);
GETTEMPS(M);
release(echan);
RETURN(top);
end "GC";
! Allocation of memory space;
INTEGER PROC ALLOCATE(INTEGER ARRAY M;INTEGER HOWMANY);
BEGIN "AL"
integer newtop;
! If we've got space, give it;
if HOWMANY + TOP < MSIZE then RETURN((TOP ← TOP + HOWMANY)-HOWMANY);
! Else look for space;
if (newtop ← GARBAGECOLLECT (M,howmany))≥ 0 then
RETURN((TOP ← TOP + HOWMANY)-HOWMANY)
else return(-1);
END "AL";
! Deleting or creating a fontable;
simp PROC DELETE(INTEGER WHICHTABLE );
FT[WHICHTABLE] ← -1;
simp INTEGER PROC DEFINEFONT(INTEGER ARRAY M;INTEGER WHICHTABLE,reente(0));
begin
integer begat,i;
begat ← allocate(M,'400);
if begat<0 then return(begat);
for i ← begat til begat + '377 do M[i]←0;
FT[whichtable]←begat;
return(begat);
end;
! FONT FILE TO PIXEL CONVERSION the G command;
! Takes an input string, requests that that file be openned.
The size of that array (ITTAKES) is requested from the memory allocator,
and the font is read into memory.;
integer proc getfont(integer array M;
string typed;integer ctmode;integer reenter(0));
begin "getf"
own integer ittakes,onchan;
integer ccnt,cbrk,ceof,goesto;
if ¬reenter then
begin "startup";
onchan←GETMEONEOF(typed,"FNT",ccnt,cbrk,ceof,'10,19,0,1);
if onchan<0 then return(0);
ittakes ← HOWBIG;
delete(CTMODE);
end "startup";
goesto ← allocate(M,ITTAKES);
if goesto <0 then return(ERR);
! If more memory was required, request restarting;
arryin(onchan,M[goesto],ittakes);
release(onchan);
FT[ctmode]←goesto;
if ctmode≥0 then
tpri(<"Input of "&typed&" into table "&cvs(ctmode)&" completed">);
end "getf";
! PIXEL TO FONT CONVERSION. The P command PUTFONT;
integer proc PUTFONT(integer array M;integer whichtable;string onfile);
begin "PF"
integer achan,asize,adum,returnme;
if FT[whichtable]<0 then
begin "ITSNOTTHERE"
tpri(<"Font "&cvs(whichtable)&" is not defined">);
return(-1);
end "ITSNOTTHERE";
achan ← GETMEONEOF(onfile,"FNT",adum,adum,adum,'10,0,19,0,"DSK");
if achan<0 then return(0);
returnme←putfontx(M,achan,FT[whichtable]);
release(achan);
return(returnme);
end "PF";
! Procedures STOW and STASH that are used by the M command;
simp PROC STOW(INTEGER GFB);
BEGIN "sto"
gfw ← (gfw lsh 8) + (gfb land '377);
incr(byte_count);
if byte_count mod 4 = 0 then
begin
gfm[word_count] ← gfw lsh 4;
incr(word_count);
gfw ← 0;
end;
END "sto";
simp PROC STASH(INTEGER GFB);
BEGIN "sta"
dirw ← (dirw lsh 8) + (gfb land '377);
incr(dir_byte_count);
if dir_byte_count mod 4 = 0 then
begin
gfdir[dir_word_count] ← dirw lsh 4;
incr(dir_word_count);
dirw ← 0;
end;
END "sta";
simp PROC RESTOW(INTEGER GFB,BC);
BEGIN
integer wc,b;
b ← 28 -((bc mod 4) * 8);
gfb ← (gfb land '377) lsh b;
wc ← bc div 4;
gfm[wc] ← gfm[wc] lor gfb;
END;
! PIXEL to GF CONVERSION: the M (Make GF) command. FNT_2_GF;
procedure fnt_2_GF(INTEGER ARRAY M;
integer onchannel,startingat,charwidth,character,height,baselinehi);
begin "f2gf"
! Takes the glyph at location startingat, and translates it
into GF representation, putting the result on channel onchannel.
The glyph is character, the font width is charwidth;
integer wide,left_kern,rows_top,data_rows;
integer max_m,del_m,max_n,del_n,dm; ! Eight bit GF bytes;
integer min_p,sum_p,min_m,min_n;
integer w,p; ! For GF byte char width and data pointer;
integer w_count;
label blank_char;
! define hppp = 348219;
define hppp = 272046;
define stash4(xyz) = ⊂
stash((xyz lsh -24) land '377);
stash((xyz lsh -16) land '377);
stash((xyz lsh -8) land '377);
stash(xyz land '377) ⊃;
! Wide is the actual width of this particular character, left_kern its
left kerning (with + to the left in this case).
Rows_top is the number of rows from the top of the glyph (which are
blanks). Data_rows is the number of rows in this glyph;
integer i,j,therebe,weat,therow,itis,itwas,column;
integer therebe_sav,weat_sav,itis_sav;
integer blankrows,p_count,saved_loc;
boolean blankflag,first_change;
define change_c = ⊂
begin
if not first_change then
begin
if p_count ≥ 64 then stow(paint1);
stow(p_count);
end
else begin
if therow > 1 and blankrows = 0 then
begin
if itis < 0 then
begin
p_count ← p_count - min_m;
stow(new_row + p_count);
end
else begin
stow(new_row);
if p_count ≥ 64 then stow(paint1);
stow(p_count);
end
end
else begin
if itis <0 then p_count ← p_count - min_m else stow(0);
if p_count ≥ 64 then stow(paint1);
stow(p_count);
end;
first_change ← false;
end;
itwas ← itis;
sum_p ← sum_p + p_count;
p_count ← 1;
end ⊃;
define paint1 = 64; ! move right a given number of columns then switch colors;
define boc = 67; ! beginning of a character;
define boc1 = 68; ! abbreviated boc, followed by 5 bytes;
define eoc = 69; ! end of a character;
define skip0 = 70; ! skip no blank rows;
define skip1 = 71; ! skip over blank rows as specfied in next byte;
define new_row = 74; ! move down one row and then right;
define char_loc0 = 246; ! character locators in the postamble;
! outstr("c="&cvs(character)&" charwidth="&cvs(charwidth)&
" wide="&cvs(wide)&crlf);
wide ← M[startingat] lsh -27;
if wide = 0 then wide ← charwidth;
left_kern ← M[startingat+1] ash -27;
! if left_kern ≠ 0 then
tpri(<" left_kern = "&cvs(left_kern)&" ">);
rows_top ← (M[startingat+1] lsh -18) land '777;
data_rows ← M[startingat+1] land '777777;
! if data_rows = 0 then goto blank_char;
del_n ← data_rows;
max_n ← baselinehi - rows_top;
stash(char_loc0);
stash(character);
stash(charwidth); ! The dm value;
w ← charwidth * (1048576/10) * (65536 / hppp);
! w ← wide * (1048576/10) * (65536 / hppp);
! outstr(" w "&cvs(w)&" ");
stash4(w);
stash4(byte_count);
stow(boc1);
stow(character);
saved_loc ← byte_count; ! Saved to allow later corrections;
stow(0); ! Save space for del_m;
stow(0); ! Save space for max_m;
stow(0); ! Save space for del_n;
stow(0); ! Save space for max_n;
weat ← startingat + 1;
itwas ← 1;
itis ← M[weat ←weat + 1];
min_p ← '7777; ! Any large number will do.
max_m ← -255;
if wide > 36 then
begin "bigc"
weat ← startingat + 1;
w_count ← (wide div 36) +1;
while true do
begin "w1"
for i ← 1 til w_count do
if M[weat + i] ≠ 0 then done "w1";
weat ← weat + w_count;
decr(data_rows);
incr(rows_top);
decr(del_n);
decr(max_n);
end "w1";
! It will be desirable to make a preliminary scan of the data to determine
the value of min_m.;
weat_sav ← weat;
min_m ← '376;
for therow ← 1 til data_rows do
begin "pre_scan"
itis ← M[weat ← weat + 1];
while true do
begin "pre_w2"
for i ← 0 til w_count - 1 do
if M[weat + i] ≠ 0 then done "pre_w2";
weat ← weat + w_count;
incr(therow);
end "pre_w2";
p_count ← 0;
itwas ← itis;
for column ← 1 til wide do
begin
if itwas ≥ 0 then
begin
if itis ≥ 0 then incr(p_count) else itwas ← -1;
end;
itis ← itis lsh 1;
if column mod 36 = 0 ∧ column≠wide then
itis ← M[weat ← weat + 1];
end;
if min_m > p_count then min_m ← p_count;
end "pre_scan";
weat ← weat_sav;
for therow ← 1 til data_rows do
begin "dorows"
itis ← M[weat ← weat + 1];
blankrows ← 0;
while true do
begin "w2"
for i ← 1 til w_count do
if M[weat + i] ≠ 0 then done "w2";
weat ← weat + w_count;
incr(blankrows);
incr(therow);
end "w2";
if blankrows > 0 then
begin
stow(skip1);
stow(blankrows);
end;
first_change ← true;
sum_p ← 0;
p_count ← 0;
itwas ← itis;
for column ← 1 til wide do
begin
if itwas ≥ 0 then
begin
if itis ≥ 0 then incr(p_count) else change_c;
end
else
begin
if itis < 0 then incr(p_count) else change_c;
end;
itwas ← itis;
itis ← itis lsh 1;
if column mod 36 = 0 ∧ column≠wide then
itis ← M[weat ← weat + 1];
end;
if p_count > 0 and itwas < 0 then change_c;
if max_m < sum_p then max_m ← sum_p;
sum_p ← 0;
end "dorows";
end "bigc"
else
begin "litc"
therebe ← point(wide,M[startingat+1],35);
itis ← ildb(therebe) lsh (36 - wide);
while itis = 0 do
begin
decr(data_rows);
incr(rows_top);
decr(del_n);
decr(max_n);
itis ← ildb(therebe) lsh (36 - wide);
end;
! We must interrupt this also to do a pre_scan;
therebe_sav ← therebe;
itis_sav ←itis;
for therow ← 1 til data_rows do
begin "pre_lit"
if therow >1 then itis ← ildb(therebe) lsh (36 - wide);
while itis = 0 do
begin
incr(therow);
itis ← ildb(therebe) lsh (36 - wide);
end;
p_count ← 0;
itwas ← itis;
for column ← 1 til wide do
begin
if itwas ≥ 0 then
begin
if itis ≥ 0 then incr(p_count);
end;
itis ←itis lsh 1;
end;
if min_m > p_count then min_m ← p_count;
end "pre_lit";
therebe ← therebe_sav;
itis ← itis_sav;
for therow ← 1 til data_rows do
begin "litdorows"
if therow >1 then itis ← ildb(therebe) lsh (36 - wide);
blankrows ← 0;
while itis = 0 do
begin
incr(blankrows);
incr(therow);
itis ← ildb(therebe) lsh (36 - wide);
end;
if blankrows > 0 then
begin
stow(skip1);
stow(blankrows);
end;
first_change ← true;
sum_p ← 0;
p_count ← 0;
itwas ← itis;
for column ← 1 til wide do
begin
if itwas ≥ 0 then
begin
if itis ≥ 0 then incr(p_count) else change_c;
end
else
begin
if itis < 0 then incr(p_count) else change_c;
end;
itwas ← itis;
itis ← itis lsh 1;
end;
if p_count > 0 and itwas < 0 then change_c;
if max_m < sum_p then max_m ← sum_p;
sum_p ← 0;
end "litdorows";
end "litc";
max_m ← max_m + min_m - left_kern;
! max_m ← max_m + min_m - left_kern + 1;
! min_m ← min_p - left_kern;
del_m ← max_m - min_m;
restow(del_m,saved_loc);
restow(max_m,saved_loc +1);
restow(del_n,saved_loc +2);
restow(max_n,saved_loc +3);
min_n ← max_n - del_n + 1;
if mmax_m < max_m + 1 then mmax_m ← max_m + 1;
if mmin_m > min_m then mmin_m ← min_m;
if mmax_n < max_n then mmax_n ← max_n;
if mmin_n > min_n then mmin_n ← min_n;
max_m ← 0;
stow(eoc);
blank_char:
outstr(pname(character));
end "f2gf";
! PIXEL TO GF FONT CONVERSION. The M command WRITEGF;
integer proc writegf(integer array M;integer ctmode;string onfile);
begin "wgf"
integer achan,asize,adum,returnme,i,j,cha;
define pre = 247; ! preamble;
define no_op = 244; ! no operation;
define post = 248; ! postamble;
define post_post = 249; ! postamble;
define I_D = 131; ! GF identification number;
! define hppp = 348219;
define hppp = 272046;
! define vppp = 348219;
define vppp = 272046;
define ds = 10485760; ! GF's ds;
! define ds = 12582912; ! GF's ds;
define stash4(wxy) = ⊂
stash((wxy lsh -24) land '377);
stash((wxy lsh -16) land '377);
stash((wxy lsh -8) land '377);
stash(wxy land '377) ⊃;
define stow4(gfh) = ⊂
stow((gfh lsh -24) land '377);
stow((gfh lsh -16) land '377);
stow((gfh lsh -8) land '377);
stow(gfh land '377) ⊃;
if FT[ctmode]<0 then
begin "ITSNOTTHERE"
tpri(<"Font "&cvs(ctmode)&" is not defined">);
return(-1);
end "ITSNOTTHERE";
i ← 0;
word_count ← 0;
byte_count ← 0;
dir_word_count ← 0;
dir_byte_count ← 0;
mmax_m ← -256;
mmin_m ← 256;
mmax_n ← -256;
mmin_n ← 256;
stow(pre); ! GF PRE command;
stow(I_D); ! GF ID number;
stow(1); ! Only one byte to follow;
stow(0); ! No message at present;
achan ← GETMEONEOF(onfile,"GF",adum,adum,adum,'10,0,19,0,"DSK");
if achan<0 then return(0);
for cha ← 0 til '177 do
if M[ctmode+cha] land '777777 then
fnt_2_gf(M,achan,
((M[FT[ctmode]+cha] lsh 18) ash -18)+FT[ctmode],
(M[FT[ctmode]+cha] lsh -18),cha,M[FT[ctmode]+'201],
M[FT[ctmode]+'203]);
i ← byte_count;
while byte_count mod 4 ≠ 3 do stow(no_op); ! To end POST with full word;
j ← byte_count;
stow(post);
stow4(i); ! Points to byte following last EOC;
stow4(ds); ! GF's ds;
stow4(0); ! Save for GF's cs;
stow4(hppp); ! GF's hppp;
stow4(vppp); ! GF's vppp;
stow4(mmin_m);
stow4(mmax_m);
stow4(mmin_n);
stow4(mmax_n);
stash(post_post);
stash4(j); ! Points to POST command;
stash(I_D);
for i ← 1 til 4 do stash(223);
while (dir_byte_count mod 4) ≠ 0 do stash(223);
arryout(achan,gfm[0],word_count);
arryout(achan,gfdir[0],dir_word_count);
release(achan);
return(returnme);
end "wgf";
! Assignment;
! CHARACTER ASSIGNMENTS: the A command;
INTEGER PROC ASSIGN(INTEGER ARRAY M;INTEGER TOCHAR,TOTABLE,FROMCHAR,FROMTABLE);
begin "ass"
integer whereto;
if FT[FROMTABLE]<0 then
begin
outstr("Font "&cvs(FROMTABLE)&" is not defined"&crlf);
return(0);
end
else
if FT[TOTABLE]<0 then
begin
whereto ← DEFINEFONT(M,TOTABLE);
if whereto<0 then return(ERR);
outstr("Defining new font table "&cvs(TOTABLE)&"."&crlf);
end;
M[FT[TOTABLE]+TOCHAR]←
(M[FT[FROMTABLE]+FROMCHAR] land '777777000000) lor
(((M[FT[FROMTABLE]+FROMCHAR] lsh 18 ash -18) +FT[FROMTABLE]
- FT[TOTABLE])land '777777);
return(0);
end "ass";
! The Assign (A) command;
INTEGER PROC ASSIGNCHAR(integer array M;integer prefix;string typed;
integer reenter);
begin "ac"
own integer charfrom,charto,tablefrom,tableto,tmp;
if ¬reenter then
begin"figureout"
if prefix then typed ← prefix & typed;
if typed="#" then begin tmp←lop(typed);charto ← octscan(typed) end
else charto ← lop(typed);
if typed ="""" then
begin tableto←2; tmp←lop(typed) end
else
if typed ="'" then
begin tableto←1; tmp←lop(typed) end
else
tableto←0;
do tmp←lop(typed) until ¬typed ∨ tmp = "←" ;
if ¬typed then
begin
tpri("Syntax error in assignment");
return(0);
end;
if typed="#" then begin tmp←lop(typed);charfrom ← octscan(typed) end
else charfrom ← lop(typed);
if typed ="""" then
begin tablefrom←2; tmp←lop(typed) end
else
if typed ="'" then
begin tablefrom←1; tmp←lop(typed) end
else
tablefrom←0;
end "figureout";
return(ASSIGN(M,charto,tableto,charfrom,tablefrom));
end "ac";
! The I command;
integer proc ICHAR(integer array M;string ifile;integer whichtable,reenter(0));
begin "iproc"
integer whatfound,howfew,ich;
integer array wantme[0:'177];
if reenter≤1 then
begin
whatfound ← getfont(M,ifile,-1);
if whatfound < 0 then return(ERR lor 1);
end;
if reenter≤2 then
begin
if FT[whichtable]<0 then whatfound ← definefont(M,whichtable);
if whatfound < 0 then return(ERR lor 2);
end;
howfew←charscan(wantme);
if howfew<0 then
begin "dontwantme"
outstr(" Aborted."&crlf);
return(0);
end "dontwantme";
for ich ← 0 til '177 do if wantme[ich] then
begin
ASSIGN (M,ich,whichtable,ich,-1);
howfew ← howfew -1;
if howfew = 0 then return(0);
end;
tpri(<"Input completed">);
end "iproc";
! PIXEL to STARS CONVERSION: the W command;
procedure fnt_2_stars(INTEGER ARRAY M;
integer onchannel,startingat,charwidth,character,height,baselinehi);
begin "f2s"
! Takes the glyph at location startingat, and translates it
to star/dot representation, putting the result on channel onchannel.
The glyph is character, the font width is charwidth;
integer wide,left_kern,rows_top,data_rows;
! Wide is the actual width of this particular character, left_kern its
left kerning. Rows_top is the number of rows from the top of the glyph
(which are blanks). Data_rows is the number of rows in this glyph;
integer i,j,therebe,weat,therow,itbe,column;
define blankline(n) = ⊂ for i ← 1 til n do out(onchannel,dot) ⊃;
define outplace = ⊂
if itbe < 0 then out(onchannel,star) else out(onchannel,dot);
itbe ← itbe lsh 1 ⊃;
wide ← M[startingat] lsh -27;
if wide = 0 then wide ← charwidth;
left_kern ← M[startingat+1] ash -27;
rows_top ← (M[startingat+1] lsh -18) land '777;
data_rows ← M[startingat+1] land '777777;
out(onchannel,pname(character)&":"&cvs(charwidth)&","&cvs(left_kern)&
","&cvs(baselinehi)&crlf&crlf);
for j ← 1 til rows_top do
begin
blankline(wide);
out(onchannel,crlf);
end;
if wide > 36 then
weat ← startingat + 1
else
therebe ← point(wide,M[startingat+1],35);
for therow ← 1 til data_rows do
begin
if wide > 36 then
begin "bigchar"
itbe ← M[weat ← weat + 1];
for column ← 1 til wide do
begin
outplace;
if column mod 36 = 0 ∧ column≠wide then
itbe ← M[weat ← weat + 1];
end;
end "bigchar"
else
begin "litchar"
itbe ← ildb(therebe) lsh (36 - wide);
for column ← 1 til wide do
begin
outplace;
end
end "litchar";
out(onchannel,crlf);
end;
for j ← 1 til height - data_rows - rows_top do
begin
blankline(wide);
out(onchannel,crlf);
end;
end "f2s";
! Writestar: the W command;
integer proc writestar(INTEGER ARRAY M;string typed;integer ctmode;STRING DEVISE);
begin "ws"
integer array dem[0:'177];
integer array directory[2:130];
integer i,cha,firstpage,demall,character;
integer schan,isdum,firstrecs,nextwrite,pages,endrite;
string filing,otherfiling;
if FT[ctmode]< 0 then
begin
tpri(<"Font number "&cvs(ctmode)&" is not defined">);
return(0);
end;
SCHAN←GETMEONEOF(TYPED,"CHR",ISDUM,ISDUM,ISDUM,0,0,19,0,DEVISE);
IF SCHAN<0 THEN RETURN(0);
demall←CHARSCAN(DEM);
if demall<0 then
begin "ddontwantme"
outstr(" Aborted."&crlf);
release(schan,3); ! forget about file on channel;
return(0);
end "ddontwantme";
pages ← 1;
if equ(devise,"TTY") then
cleardisplay
else
begin "disk"
! space for directory page;
firstrecs ← (123+32*demall)/640 + 1; ! sort of the maximum size of the
directory page, in records, assuming certain things
about what's printed;
for i ← 1 til firstrecs do
begin
useto(schan,i);
out(schan,0);
end;
end "disk";
for cha ← 0 til '177 do if dem[cha] then
if M[FT[ctmode]+cha] land '777777 then
begin "mewanted"
if escape_I then
begin "ei"
outstr(crlf&"Escape I termination at: "&pname(cha)&crlf);
release(schan);
return(cha);
end "ei";
if ¬equ(devise,"TTY") then
begin "formattedio"
ugetf(isdum,schan,nextwrite);
useto(schan,nextwrite);
out(schan,ff);
pages ← pages + 1;
directory[pages] ← (cha lsh 18) lor nextwrite;
outstr(pname(cha)&" ");
end "formattedio";
fnt_2_stars(M,schan,
((M[FT[ctmode]+cha] lsh 18) ash -18)+FT[ctmode],
(M[FT[ctmode]+cha] lsh -18),cha,M[FT[ctmode]+'201],
M[FT[ctmode]+'203]);
end "mewanted"
else
if ¬allseen then tpri(pname(cha)&" is not defined.");
! Create the directory page;
if ¬equ(devise,"TTY") then
begin "contents"
ugetf(isdum,schan,endrite);
useto(schan,1);
out(schan,
"COMMENT ⊗ VALID "&fullnumb(pages)&" PAGES"&crlf&
"C REC PAGE DESCRIPTION"&crlf&
"C00001 00001"&crlf);
for i ← 2 til pages do
begin "dirline"
character ← directory[i] lsh -18;
out(schan,
"C"&fullnumb(directory[i] land '777777)&" "&
fullnumb(i)&tab&
pname(character)&":"&cvs(M[FT[ctmode]+character] lsh -18)&","&
cvs(M[((M[FT[ctmode]+character] lsh 18) ash -18)+FT[ctmode]+1] ash -27)&
","&cvs(M[FT[ctmode]+'203])&crlf);
end "dirline";
out(schan,"C"&fullnumb(endrite)&" ENDMK"&crlf&
"C⊗;"&crlf);
end "contents";
release(schan);
IF ¬equ(devise,"TTY") then tpri(<crlf&"Writing star file "&filing&" completed">);
return(0);
end "ws";
! PIXEL to Z_STARS CONVERSION: the Z command;
procedure fnt_Z_stars(INTEGER ARRAY M;
integer onchannel,startingat,charwidth,character,height,baselinehi);
begin "fzs"
! Takes the glyph at location startingat, expand it by 2 (approximating
1.92 for the DOVER) smooth it and translates it to star/dot representation,
putting the result on channel onchannel.
This version first expands the glyph in the x direction storing it in an
array called GLYPH, then smooths it using a 5 by 5 template. It then
expands the glyph in the y direction, during the process of writing the
glyph out in star/dot format on an output file, and does a final smoothing
operation on th newly generated rows using a 7 by 5 template.
The glyph is character, the font width is charwidth;
integer wide,left_kern,rows_top,data_rows;
! Wide is the actual width of this particular character, left_kern its
left kerning. Rows_top is the number of rows from the top of the glyph
(which are blanks). Data_rows is the number of rows in this glyph;
integer i,j,k,n,therebe,weat,theword,therow,itwas,itbe,bits,column;
integer ba,da,ab,bb,cb,db,eb,bc,cc,dc,ad,bd,cd,dd,ed,be,de;
integer quad,quad1,quad2,quad3,quad4;
integer array glyph[-1:12,-2:109];
integer array newrow[-1:12];
define blankline(n) = ⊂ for i ← 1 til n do out(onchannel,dot) ⊃;
define outplace = ⊂
begin
if itbe < 0 then out(onchannel,star) else out(onchannel,dot);
itbe ← itbe lsh 1;
end ⊃;
define gettwo = ⊂
if itbe < 0 then
begin
if itwas < 0 then bits ← 3 else bits ← 1;
end else
begin
bits ← 0;
end;
glyph[theword,therow] ← (glyph[theword,therow] lsh 2) lor bits;
itwas ← itbe;
itbe ← itbe lsh 1 ⊃;
wide ← M[startingat] lsh -27;
if wide = 0 then wide ← charwidth;
left_kern ← M[startingat+1] ash -27;
rows_top ← (M[startingat+1] lsh -18) land '777;
data_rows ← M[startingat+1] land '777777;
out(onchannel,pname(character)&":"&cvs(charwidth*2-1)&","&
cvs(left_kern)&
","&cvs(baselinehi*2-1)&crlf&crlf);
! Load array with glyph, expand x dimension in the process.;
if wide > 36 then
begin "bigchar"
weat ← startingat + 1;
for therow ← 1 til data_rows do
begin
itwas ← 0;
theword ← 0;
itbe ← M[weat ← weat + 1];
! outstr(" itbe "&cvos(itbe)&" ");
while (theword +1) * 18 < wide do
begin
for n ←1 til 18 do
begin
gettwo;
end;
theword ← theword + 1;
if theword mod 2 = 0 then itbe ← M[weat ← weat + 1];
end;
for n ← (theword * 18) +1 til wide do
begin
gettwo;
end;
n ← 2 *((theword + 1) * 18 - wide);
glyph[theword,therow] ← glyph[theword,therow] lsh n;
glyph[theword+1,therow] ← 0;
end;
end "bigchar"
else
begin "litchar"
therebe ← point(wide,M[startingat+1],35);
for therow ← 1 til data_rows do
begin
itwas ← 0;
theword ← 0;
itbe ← ildb(therebe) lsh (36 - wide);
if wide > 18 then
begin
for n ←1 til 18 do
begin
gettwo;
end;
theword ← 1;
end;
for n ← (theword * 18) + 1 til wide do
begin
gettwo;
end;
n ← 2 * ((theword + 1) * 18 - wide);
glyph[theword,therow] ← glyph[theword,therow] lsh n;
glyph[theword+1,therow] ← 0;
end;
end "litchar";
wide ← (wide * 2);
rows_top ← rows_top * 2;
! Now we smooth the extended rows a full word at a time by referencing this
array
horizontal
-2 -1 0 1 2
v -2 ba da
e -1 ab bb cb db eb
r 0 bc cc dc
t 1 ad bd cd dd ed
2 be de
with the terms defined as done below and with cc locating possible zeros that
should perhaps be changed to ones;
for therow ← 2 til data_rows - 1 do
begin "smooth_rows"
theword ← 0;
while (theword * 36) < wide do
begin "smooth_words"
da ← glyph[theword,therow-2];
ba ← (glyph[theword-1,therow-2] lsh 35) lor (da lsh -1);
da ← (da lsh 1) lor (glyph[theword+1,therow-2] lsh -35);
bb ← glyph[theword-1,therow-1];
cb ← glyph[theword,therow-1];
eb ← glyph[theword+1,therow-1];
ab ← (bb lsh 34) lor (cb lsh -2);
bb ← (bb lsh 35) lor (cb lsh -1);
db ← (eb lsh -35) lor (cb lsh 1);
eb ← (eb lsh -34) lor (cb lsh 2);
cc ← glyph[theword,therow];
dc ← (cc lsh 1) lor (glyph[theword+1,therow] lsh -35);
bc ← (glyph[theword-1,therow] lsh 35) lor (cc lsh -1);
bd ← glyph[theword-1,therow+1];
cd ← glyph[theword,therow+1];
ed ← glyph[theword+1,therow+1];
ad ← (bd lsh 34) lor (cd lsh -2);
bd ← (bd lsh 35) lor (cd lsh -1);
dd ← (ed lsh -35) lor (cd lsh 1);
ed ← (ed lsh -34) lor (cd lsh 2);
de ← glyph[theword,therow+2];
be ← (glyph[theword-1,therow+2] lsh 35) lor (de lsh -1);
de ← (de lsh 1) lor (glyph[theword+1,therow+2] lsh -35);
cc ← lnot cc;
quad1 ← bc land cd land cc;
if quad1 ≠ 0 then
quad1 ← quad1 land bb land dd land (lnot(ba land ed));
quad2 ← dc land cd land cc;
if quad2 ≠ 0 then
quad2 ← quad2 land bd land db land (lnot(ad land da));
quad3 ← dc land cb land cc;
if quad3 ≠ 0 then
quad3 ← quad3 land dd land bb land (lnot(de land ab));
quad4 ← bc land cb land cc;
if quad4 ≠ 0 then
quad4 ← quad4 land db land bd land (lnot(be land eb));
quad ← quad1 lor quad2 lor quad3 lor quad4;
glyph[theword,therow] ← glyph[theword,therow] lor quad;
theword ← theword + 1;
end "smooth_words";
end "smooth_rows";
for j ← 1 til rows_top do
begin
blankline(wide);
out(onchannel,crlf);
end;
! Send pattern to output file while also introducing an extra smoothed line
between each two lines of the stored pattern;
for therow ← 1 til data_rows do
begin "dorows"
n ← 1;
theword ← 0;
itbe ← glyph[0,therow];
while n + 35 < wide do
begin
for k ← 1 til 36 do outplace;
n ← n + 36;
theword ← theword + 1;
itbe ← glyph[theword,therow];
end;
for n ← n til wide do outplace;
out(onchannel,crlf);
! The next section generates an extra row, as needed, in an array NEWROW
and then smooths this row using the same technique as used earlier except
that the positions of the ab, eb, ad, and ed components have been moved out
to compensate for the previous horizontal expansion.;
if therow < data_rows then
begin "extra"
theword ← 0;
while (theword * 36) < wide do
begin
newrow[theword] ← glyph[theword,therow]
land glyph[theword, therow+1];
theword ← theword + 1;
end;
newrow[theword] ← 0;
theword ← 0;
while (theword * 36) < wide do
begin "smooth_extra"
da ← glyph[theword,therow-1];
ba ← (glyph[theword-1,therow-1] lsh 35) lor (da lsh -1);
da ← (da lsh 1) lor (glyph[theword+1,therow-1] lsh -35);
bb ← glyph[theword-1,therow];
cb ← glyph[theword,therow];
eb ← glyph[theword+1,therow];
ab ← (bb lsh 33) lor (cb lsh -3);
bb ← (bb lsh 35) lor (cb lsh -1);
db ← (eb lsh -35) lor (cb lsh 1);
eb ← (eb lsh -33) lor (cb lsh 3);
cc ← newrow[theword];
dc ← (cc lsh 1) lor (newrow[theword+1] lsh -35);
bc ← (newrow[theword-1] lsh 35) lor (cc lsh -1);
bd ← glyph[theword-1,therow+1];
cd ← glyph[theword,therow+1];
ed ← glyph[theword+1,therow+1];
ad ← (bd lsh 33) lor (cd lsh -3);
bd ← (bd lsh 35) lor (cd lsh -1);
dd ← (ed lsh -35) lor (cd lsh 1);
ed ← (ed lsh -33) lor (cd lsh 3);
de ← glyph[theword,therow+2];
be ← (glyph[theword-1,therow+2] lsh 35) lor (de lsh -1);
de ← (de lsh 1) lor (glyph[theword+1,therow+2] lsh -35);
cc ← lnot cc;
quad1 ← bc land cd land cc;
if quad1 ≠ 0 then
quad1 ← quad1 land bb land dd land (lnot(ba land ed));
quad2 ← dc land cd land cc;
if quad2 ≠ 0 then
quad2 ← quad2 land bd land db land (lnot(ad land da));
quad3 ← dc land cb land cc;
if quad3 ≠ 0 then
quad3 ← quad3 land dd land bb land (lnot(de land ab));
quad4 ← bc land cb land cc;
if quad4 ≠ 0 then
quad4 ← quad4 land db land bd land (lnot(be land eb));
quad ← quad1 lor quad2 lor quad3 lor quad4;
newrow[theword] ← newrow[theword] lor quad;
theword ← theword + 1;
end "smooth_extra";
newrow[theword] ← 0;
n ← 1;
theword ← 0;
itbe ← newrow[theword];
while n + 35 < wide do
begin
for k ← 1 til 36 do outplace;
n ← n + 36;
theword ← theword + 1;
itbe ← newrow[theword];
end;
for n ← n til wide do outplace;
out(onchannel,crlf);
end "extra";
end "dorows";
for j ← 1 til height * 2 + 1 - data_rows * 2 - rows_top do
begin
blankline(wide);
out(onchannel,crlf);
end;
end "fzs";
! Z_Writestar: the Z command;
integer proc Z_star(INTEGER ARRAY M;string typed;integer ctmode;STRING DEVISE);
begin "zs"
integer array dem[0:'177];
integer array directory[2:130];
integer i,cha,firstpage,demall,character;
integer schan,isdum,firstrecs,nextwrite,pages,endrite;
string filing,otherfiling;
if FT[ctmode]< 0 then
begin
tpri(<"Font number "&cvs(ctmode)&" is not defined">);
return(0);
end;
SCHAN←GETMEONEOF(TYPED,"CHR",ISDUM,ISDUM,ISDUM,0,0,19,0,DEVISE);
IF SCHAN<0 THEN RETURN(0);
demall←CHARSCAN(DEM);
if demall<0 then
begin
outstr(" Aborted."&crlf);
release(schan,3); ! forget about file on channel;
return(0);
end;
pages ← 1;
if equ(devise,"TTY") then
cleardisplay
else
begin "disk"
! space for directory page;
firstrecs ← (123+32*demall)/640 + 1; ! sort of the maximum size of the
directory page, in records, assuming certain things
about what's printed;
for i ← 1 til firstrecs do
begin
useto(schan,i);
out(schan,0);
end;
end "disk";
for cha ← 0 til '177 do if dem[cha] then
if M[FT[ctmode]+cha] land '777777 then
begin "mewanted"
if escape_I then
begin "ei"
outstr(crlf&"Escape I termination at: "&pname(cha)&crlf);
release(schan);
return(cha);
end "ei";
if ¬equ(devise,"TTY") then
begin "formattedio"
ugetf(isdum,schan,nextwrite);
useto(schan,nextwrite);
out(schan,ff);
pages ← pages + 1;
directory[pages] ← (cha lsh 18) lor nextwrite;
outstr(pname(cha)&" ");
end "formattedio";
fnt_Z_stars(M,schan,
((M[FT[ctmode]+cha] lsh 18) ash -18)+FT[ctmode],
(M[FT[ctmode]+cha] lsh -18),cha,M[FT[ctmode]+'201],
M[FT[ctmode]+'203]);
end "mewanted"
else
if ¬allseen then tpri(pname(cha)&" is not defined.");
! Create the directory page;
if ¬equ(devise,"TTY") then
begin "contents"
ugetf(isdum,schan,endrite);
useto(schan,1);
out(schan,
"COMMENT ⊗ VALID "&fullnumb(pages)&" PAGES"&crlf&
"C REC PAGE DESCRIPTION"&crlf&
"C00001 00001"&crlf);
for i ← 2 til pages do
begin "dirline"
character ← directory[i] lsh -18;
out(schan,
"C"&fullnumb(directory[i] land '777777)&" "&
fullnumb(i)&tab&
pname(character)&":"&cvs(M[FT[ctmode]+character] lsh -18)&","&
cvs(M[((M[FT[ctmode]+character] lsh 18) ash -18)+FT[ctmode]+1] ash -27)&
","&cvs(M[FT[ctmode]+'203])&crlf);
end "dirline";
out(schan,"C"&fullnumb(endrite)&" ENDMK"&crlf&
"C⊗;"&crlf);
end "contents";
release(schan);
IF ¬equ(devise,"TTY") then tpri(<crlf&"Writing (2.0 times) star file completed">);
return(0);
end "zs";
! PIXEL to N_STARS CONVERSION: the N command;
procedure fnt_N_stars(INTEGER ARRAY M;
integer onchannel,startingat,charwidth,character,height,baselinehi);
begin "fns"
! Takes the glyph at location startingat, expand it by 1.5 (for the
IMAGEN) smooths it and translates it to star/dot representation, putting
the result on channel onchannel.
This version first expands the glyph in the x direction storing it in an
array called GLYPH, then smooths it using a 5 by 5 template. It then
expands the glyph in the y direction, during the process of writing the
glyph out in star/dot format on an output file, and does a final smoothing
operation on th newly generated rows using a 7 by 5 template.
Under certain circumstances this procedure does a better job than does
FSCALE, but this is not always the case, so it is wise to try both methods.
The glyph is character, the font width is charwidth;
integer wide,left_kern,rows_top,data_rows;
! Wide is the actual width of this particular character, left_kern its
left kerning. Rows_top is the number of rows from the top of the glyph
(which are blanks). Data_rows is the number of rows in this glyph;
integer i,j,k,n,therebe,weat,theword,therow,itwas,itbe,bits,column;
integer ba,da,ab,bb,cb,db,eb,bc,cc,dc,ad,bd,cd,dd,ed,be,de;
integer quad,quad1,quad2,quad3,quad4;
integer array glyph[-1:12,-2:109];
integer array newrow[-1:12];
define blankline(n) = ⊂ for i ← 1 til n do out(onchannel,dot) ⊃;
define outplace = ⊂
begin
if itbe < 0 then out(onchannel,star) else out(onchannel,dot);
! if itbe <0 then outstr("*") else outstr(".");
itbe ← itbe lsh 1;
end ⊃;
define getbits = ⊂
if j mod 2 = 0 then
begin
if itbe < 0 then bits ← 1 else bits ← 0;
glyph[theword,therow] ← (glyph[theword,therow] lsh 1) lor bits;
end else
begin
if itbe < 0 then
begin
if itwas < 0 then bits ← 3 else bits ← 1;
end else
begin
bits ← 0;
end;
glyph[theword,therow] ← (glyph[theword,therow] lsh 2) lor bits;
end;
j ← j + 1;
itwas ← itbe;
itbe ← itbe lsh 1 ⊃;
wide ← M[startingat] lsh -27;
if wide = 0 then wide ← charwidth;
left_kern ← M[startingat+1] ash -27;
rows_top ← (M[startingat+1] lsh -18) land '777;
data_rows ← M[startingat+1] land '777777;
out(onchannel,pname(character)&":"&cvs((charwidth*3) div 2)&","&
cvs(left_kern)&","&cvs((baselinehi*3) div 2)&crlf&crlf);
! Load the glyph array, expand the X dimension in the process. When
required, ones are introduced if the two surrounding bits are ones and
zeros are introduced otherwise, with the possibility that the some of the
zeros may later be changed to ones during the smoothing operation.;
if wide > 36 then
begin "bigchar"
weat ← startingat + 1;
for therow ← 1 til data_rows do
begin
itwas ← 0;
theword ← 0;
i ← 0;
j ← 0;
while (theword +1) * 24 < wide do
begin
if j mod 36 = 0 then itbe ← M[weat ← weat + 1];
for n ←1 til 12 do
begin
getbits;
end;
if j mod 24 = 0 then
begin
theword ← theword + 1;
end;
end;
for n ← (theword * 24) +1 til wide do
begin
if j mod 36 = 0 then itbe ← M[weat ← weat + 1];
getbits;
end;
n ← 2 *((theword + 1) * 24 - wide);
glyph[theword,therow] ← glyph[theword,therow] lsh n;
glyph[theword+1,therow] ← 0;
end;
end "bigchar"
else
begin "litchar"
therebe ← point(wide,M[startingat+1],35);
for therow ← 1 til data_rows do
begin
itwas ← 0;
theword ← 0;
j ← 0;
itbe ← ildb(therebe) lsh (36 - wide);
if wide > 24 then
begin
for n ←1 til 24 do
begin
getbits;
end;
theword ← 1;
for n← 25 til wide do
begin
getbits;
end;
end else
begin
for n ← 1 til wide do
begin
getbits;
end;
end;
n ← (theword + 1) * 36 - ((3 * wide) div 2);
glyph[theword,therow] ← glyph[theword,therow] lsh n;
glyph[theword+1,therow] ← 0;
end;
end "litchar";
wide ← (wide * 3) div 2;
rows_top ← (rows_top * 3) div 2;
! Now we smooth the extended rows a full word at a time by referencing this
array
horizontal
-2 -1 0 1 2
v -2 ba da
e -1 ab bb cb db eb
r 0 bc cc dc
t 1 ad bd cd dd ed
2 be de
with the terms defined as done below and with cc locating possible zeros that
should perhaps be changed to ones;
for therow ← 2 til data_rows - 1 do
begin "smooth_rows"
theword ← 0;
while (theword * 36) < wide do
begin "smooth_words"
da ← glyph[theword,therow-2];
ba ← (glyph[theword-1,therow-2] lsh 35) lor (da lsh -1);
da ← (da lsh 1) lor (glyph[theword+1,therow-2] lsh -35);
bb ← glyph[theword-1,therow-1];
cb ← glyph[theword,therow-1];
eb ← glyph[theword+1,therow-1];
ab ← (bb lsh 34) lor (cb lsh -2);
bb ← (bb lsh 35) lor (cb lsh -1);
db ← (eb lsh -35) lor (cb lsh 1);
eb ← (eb lsh -34) lor (cb lsh 2);
cc ← glyph[theword,therow];
dc ← (cc lsh 1) lor (glyph[theword+1,therow] lsh -35);
bc ← (glyph[theword-1,therow] lsh 35) lor (cc lsh -1);
bd ← glyph[theword-1,therow+1];
cd ← glyph[theword,therow+1];
ed ← glyph[theword+1,therow+1];
ad ← (bd lsh 34) lor (cd lsh -2);
bd ← (bd lsh 35) lor (cd lsh -1);
dd ← (ed lsh -35) lor (cd lsh 1);
ed ← (ed lsh -34) lor (cd lsh 2);
de ← glyph[theword,therow+2];
be ← (glyph[theword-1,therow+2] lsh 35) lor (de lsh -1);
de ← (de lsh 1) lor (glyph[theword+1,therow+2] lsh -35);
cc ← lnot cc;
quad1 ← bc land cd land cc;
if quad1 ≠ 0 then
quad1 ← quad1 land bb land dd land (lnot(ba land ed));
quad2 ← dc land cd land cc;
if quad2 ≠ 0 then
quad2 ← quad2 land bd land db land (lnot(ad land da));
quad3 ← dc land cb land cc;
if quad3 ≠ 0 then
quad3 ← quad3 land dd land bb land (lnot(de land ab));
quad4 ← bc land cb land cc;
if quad4 ≠ 0 then
quad4 ← quad4 land db land bd land (lnot(be land eb));
quad ← quad1 lor quad2 lor quad3 lor quad4;
glyph[theword,therow] ← glyph[theword,therow] lor quad;
! if quad ≠ 0 then outstr(" "&cvs(therow)&":"&cvos(quad1)&
","&cvos(quad2)&","&cvos(quad3)&","&cvos(quad4)&" ");
theword ← theword + 1;
end "smooth_words";
end "smooth_rows";
for j ← 1 til rows_top do
begin
blankline(wide);
out(onchannel,crlf);
end;
! Send pattern to output file while also introducing an extra smoothed line
between alternate pairs of lines of the stored pattern;
for therow ← 1 til data_rows do
begin "dorows"
n ← 1;
theword ← 0;
itbe ← glyph[theword,therow];
! outstr(cvs(theword)&","&cvs(therow)&" "&cvos(itbe)&crlf);
while n + 35 < wide do
begin
for k ← 1 til 36 do outplace;
n ← n + 36;
theword ← theword + 1;
itbe ← glyph[theword,therow];
! outstr(cvs(theword)&","&cvs(therow)&"+"&cvos(itbe)&crlf);
end;
for n ← n til wide do outplace;
out(onchannel,crlf);
! outstr(crlf);
! The next section generates an extra row, as needed, in an array NEWROW
and then smooths this row using the same technique as used earlier except
that the positions of the ab, eb, ad, and ed components have been moved out
to compensate for the previous horizontal expansion.;
if ((therow mod 2) = 0) and (therow < data_rows) then
begin "extra"
theword ← 0;
while (theword * 36) < wide do
begin
newrow[theword] ← glyph[theword,therow]
land glyph[theword, therow+1];
theword ← theword + 1;
end;
newrow[theword] ← 0;
theword ← 0;
while (theword * 36) < wide do
begin "smooth_extra"
da ← glyph[theword,therow-1];
ba ← (glyph[theword-1,therow-1] lsh 35) lor (da lsh -1);
da ← (da lsh 1) lor (glyph[theword+1,therow-1] lsh -35);
bb ← glyph[theword-1,therow];
cb ← glyph[theword,therow];
eb ← glyph[theword+1,therow];
ab ← (bb lsh 33) lor (cb lsh -3);
bb ← (bb lsh 35) lor (cb lsh -1);
db ← (eb lsh -35) lor (cb lsh 1);
eb ← (eb lsh -33) lor (cb lsh 3);
cc ← newrow[theword];
dc ← (cc lsh 1) lor (newrow[theword+1] lsh -35);
bc ← (newrow[theword-1] lsh 35) lor (cc lsh -1);
bd ← glyph[theword-1,therow+1];
cd ← glyph[theword,therow+1];
ed ← glyph[theword+1,therow+1];
ad ← (bd lsh 33) lor (cd lsh -3);
bd ← (bd lsh 35) lor (cd lsh -1);
dd ← (ed lsh -35) lor (cd lsh 1);
ed ← (ed lsh -33) lor (cd lsh 3);
de ← glyph[theword,therow+2];
be ← (glyph[theword-1,therow+2] lsh 35) lor (de lsh -1);
de ← (de lsh 1) lor (glyph[theword+1,therow+2] lsh -35);
cc ← lnot cc;
quad1 ← bc land cd land cc;
if quad1 ≠ 0 then
quad1 ← quad1 land bb land dd land (lnot(ba land ed));
quad2 ← dc land cd land cc;
if quad2 ≠ 0 then
quad2 ← quad2 land bd land db land (lnot(ad land da));
quad3 ← dc land cb land cc;
if quad3 ≠ 0 then
quad3 ← quad3 land dd land bb land (lnot(de land ab));
quad4 ← bc land cb land cc;
if quad4 ≠ 0 then
quad4 ← quad4 land db land bd land (lnot(be land eb));
quad ← quad1 lor quad2 lor quad3 lor quad4;
newrow[theword] ← newrow[theword] lor quad;
! if quad ≠ 0 then outstr(" "&cvs(therow)&":"&cvos(quad1)&
","&cvos(quad2)&","&cvos(quad3)&","&cvos(quad4)&" ");
theword ← theword + 1;
end "smooth_extra";
newrow[theword] ← 0;
n ← 1;
theword ← 0;
itbe ← newrow[theword];
while n + 35 < wide do
begin
for k ← 1 til 36 do outplace;
n ← n + 36;
theword ← theword + 1;
itbe ← newrow[theword];
end;
for n ← n til wide do outplace;
out(onchannel,crlf);
! outstr(crlf);
end "extra";
end "dorows";
for j ← 1 til ((height * 3) div 2)+ 1 - ((data_rows * 3) div 2) - rows_top do
begin
blankline(wide);
out(onchannel,crlf);
end;
end "fns";
! N_Writestar: the N command;
integer proc N_star(INTEGER ARRAY M;string typed;integer ctmode;STRING DEVISE);
begin "ns"
integer array dem[0:'177];
integer array directory[2:130];
integer i,cha,firstpage,demall,character;
integer schan,isdum,firstrecs,nextwrite,pages,endrite;
string filing,otherfiling;
if FT[ctmode]< 0 then
begin
tpri(<"Font number "&cvs(ctmode)&" is not defined">);
return(0);
end;
SCHAN←GETMEONEOF(TYPED,"CHR",ISDUM,ISDUM,ISDUM,0,0,19,0,DEVISE);
IF SCHAN<0 THEN RETURN(0);
demall←CHARSCAN(DEM);
if demall<0 then
begin
outstr(" Aborted."&crlf);
release(schan,3); ! forget about file on channel;
return(0);
end;
pages ← 1;
if equ(devise,"TTY") then
cleardisplay
else
begin "disk"
! space for directory page;
firstrecs ← (123+32*demall)/640 + 1; ! sort of the maximum size of the
directory page, in records, assuming certain things
about what's printed;
for i ← 1 til firstrecs do
begin
useto(schan,i);
out(schan,0);
end;
end "disk";
for cha ← 0 til '177 do if dem[cha] then
if M[FT[ctmode]+cha] land '777777 then
begin "mewanted"
if escape_I then
begin "ei"
outstr(crlf&"Escape I termination at: "&pname(cha)&crlf);
release(schan);
return(cha);
end "ei";
if ¬equ(devise,"TTY") then
begin "formattedio"
ugetf(isdum,schan,nextwrite);
useto(schan,nextwrite);
out(schan,ff);
pages ← pages + 1;
directory[pages] ← (cha lsh 18) lor nextwrite;
outstr(pname(cha)&" ");
end "formattedio";
fnt_N_stars(M,schan,
((M[FT[ctmode]+cha] lsh 18) ash -18)+FT[ctmode],
(M[FT[ctmode]+cha] lsh -18),cha,M[FT[ctmode]+'201],
M[FT[ctmode]+'203]);
end "mewanted"
else
if ¬allseen then tpri(pname(cha)&" is not defined.");
! Create the directory page;
if ¬equ(devise,"TTY") then
begin "contents"
ugetf(isdum,schan,endrite);
useto(schan,1);
out(schan,
"COMMENT ⊗ VALID "&fullnumb(pages)&" PAGES"&crlf&
"C REC PAGE DESCRIPTION"&crlf&
"C00001 00001"&crlf);
for i ← 2 til pages do
begin "dirline"
character ← directory[i] lsh -18;
out(schan,
"C"&fullnumb(directory[i] land '777777)&" "&
fullnumb(i)&tab&
pname(character)&":"&cvs(M[FT[ctmode]+character] lsh -18)&","&
cvs(M[((M[FT[ctmode]+character] lsh 18) ash -18)+FT[ctmode]+1] ash -27)&
","&cvs(M[FT[ctmode]+'203])&crlf);
end "dirline";
out(schan,"C"&fullnumb(endrite)&" ENDMK"&crlf&
"C⊗;"&crlf);
end "contents";
release(schan);
IF ¬equ(devise,"TTY") then tpri(<crlf&"Writing (times 1.5) star file completed">);
return(0);
end "ns";
! Set up directory table: SELECTDIRECT;
simp integer proc SELECTDIRECT(integer array where,howlong);
! RCHAN, the channel the file is on;
begin "sld"
integer i,j; ! Counters;
integer tmp;
integer oldrec,newrec,oldchar,newchar;
string stemp;
label errorexit;
boolean bedone;
for i ← -1 til '177 do where[i]←howlong[i]←0;
rcnt ← 200;
useti(rchan,1);
stemp ← input(rchan,linebreak); ! get COMMENT ⊗ line;
if ¬ equ(stemp[1 for 10],"COMMENT ⊗ ") then
begin
tpri(<"Not a proper ETV file">);
return(-1);
end;
stemp ← input(rchan,linebreak); ! get C REC line;
stemp ← input(rchan,linebreak); ! get C00001 line;
oldrec←1;
oldchar←-1;
bedone ← 0;
stemp ← input(rchan,linebreak); ! get first data line;
while ¬(bedone ∨ reof) do
begin "directly"
tmp ← lop(stemp);
newrec ← intscan(stemp,tmp);
bedone ← equ(stemp[2 FOR 5],"ENDMK");
while stemp≠null and stemp≠tab do tmp ← lop(stemp);
tmp ← lop(stemp);
if stemp≠"#" ∨ ¬digit(stemp[2 for 1])then newchar←stemp
else begin tmp ← lop(stemp); newchar←octscan(stemp) end;
! put record in second half, maximum length in first half;
where[oldchar] ← oldrec ;
howlong[oldchar] ← (newrec-oldrec)*33;
oldrec ← newrec;
oldchar ← newchar;
stemp ← input(rchan,linebreak); ! get next line;
end "directly";
return(0);
end "sld";
! Stars to PIXELS: the R command, STARS2LINES;
integer proc stars2lines(integer array M;string askedfor;integer wtable,reentering(0));
begin "s2l"
! This routine depends upon the global array rwhichchars. CHARSCAN sets
the requested elements of this array to 1, selectdirect sets the left half
of any element to the largest number of words that element could need, the
right half, to the record it starts at. As usual, if the allocator can't
supply the nedded words, the process is suspened and then resumed;
integer needmany,usedmany,rstart,ifound,tmp;
integer char,character_width,left_kern,glyph_width,skipme,basehi;
string instring;
label errata,continuance;
real realfound; integer intfound; ! for rounding;
integer rows_from_top,data_rows,word_count,fillword;
boolean seenrealine; ! Have we seen a non blank line?;
boolean notblankline; ! is this line blank?;
integer placeinto; ! Where to put the next word into M;
integer count_bottom_line; ! count of blank lines since last realline;
integer pattern,therebe,bitnumber;
integer i,j; ! a counter;
integer words_per; ! The number of words needed per data row for this glyph;
own integer array filling[1:fillimit]; ! The input is assembled in this
word. If the character is more than 50*36 raster points
wide, we may be in trouble;
own integer array where,howlong[-1:'177]; ! What record
does the character start at? How many words might its definition
take?;
if ¬ reentering then
begin "findout"
! Get the input file;
rchan←getmeoneof(askedfor,"CHR",rcnt,rbrk,reof,'0,19,0);
if rchan<0 then return(0);
! Ask which characters are to be read in;
howfew←charscan(rwhichchars);
if howfew<0 then
begin
outstr(" Aborted."&crlf);
release(rchan,3); ! forget about file on channel;
return(0);
end;
! Selectdirect looks at the file, and get pointer information from the directory page;
selectans ← selectdirect(where,howlong);
if selectans<0 then begin release(rchan);return(0);end;
end "findout";
if reentering then reentering ← reentering - 1; ! hack;
! If this table is undefined, define it;
if FT[wtable]<0 then rstart←DEFINEFONT(M,wtable);
! If no space, then allocate/exit;
if rstart<0 then return(ERR);
for char ← reentering til '177 do if rwhichchars[char] ∧ where[char] then
begin "eachcharacter"
! Escape I exit;
if escape_I then
begin outstr(crlf&"Quiting at "&pname(char)&crlf);
return(char);
end else outstr(pname(char)&" ");
! This contains an upper bound on the number of words needed to represent this
glyph;
if where[char]=0 then
begin
if ¬allseen then tpri(<"Unable to find"&pname(char)>);
continue;
end;
needmany ← allocate(M,howlong[char]);
! If there wasn't that much space, request a reenter/allocation sequence;
if needmany<0 then return(ERR lor (char+1));
! Move the input pointer to the block that begins that char;
useti(rchan,where[char]);
! Take the next line of text;
rcnt←500;
instring ← input(rchan,linebreak);
! Keep count of the number of characters used;
skipme←length(instring);
! If this isn't the start of a new page, there's an error;
if lop(instring)≠ ff then goto ERRATA;
! Find out which character it is;
if instring≠"#" ∨ ¬digit(instring[2 for 1])then
ifound ← lop(instring)
else
begin tmp ← lop(instring);ifound ←octscan(instring) end;
! Another type of error;
if ifound ≠ char then goto ERRATA;
tmp ← lop(instring);
! Find the character_width (advance of xgp colum select) and left_kern
(overlap with previous character) on the first line, and, maybe a height above
the baseline;
character_width ← intscan(instring,tmp);
tmp ← lop(instring);
left_kern ← intscan(instring,tmp);
tmp ← lop(instring);
basehi ← intscan(instring,tmp);
! count the # of characters til the first data line;
instring ← null;
do begin "findfirstline"
skipme ← skipme + length(instring);
instring ← input(rchan,linebreak);
end "findfirstline" until instring≠cr ∨ reof;
! new: but didn't work: while rbrk≠lf ∧ ¬reof do instring ← instring & input(rchan,linebreak);
! Now taking only one character at a time;
rcnt ← 1;
glyph_width ← length(instring)-2;
! The width of the first line is now in glyph_width;
! reset the reading process to point back at the first line;
rcnt ← skipme;
useti(rchan,where[char]);
instring ← input(rchan,0);
instring ← null;
rcnt ← 1;
! Words_per raster line;
words_per ← 1 + (glyph_width-1) div 36;
! Number of (implicit) blank rows from the top;
rows_from_top ← 0;
! number of defined data_rows in this glyph;
data_rows ← 0;
! We count blank lines at the bottom. If we find another defined line, we insert
that number of blank lines.;
count_bottom_line ← 0;
! If narrow glyph, then thereby is a pointer (DEC style) to deposit the
next byte. If not, the glyph starts at nextword. Remember to leave two
blank words for the header for this glyph;
if glyph_width≤36 then therebe ← point(glyph_width,M[needmany+1],35)
else placeinto ← needmany+1;
do begin "thisline"
pattern←if glyph_width≥36 then '400000000000 else 1 lsh (glyph_width-1);
fillword←1;
for i ← 1 til words_per do filling[i]←0;
do begin "handleline"
tmp ← input(rchan,0);
if tmp = cr ∨ tmp=ff then done "handleline";
if tmp = tab then
begin
tpri(<"Warning: I see a tab. It may not do what you think it does.">);
tmp ← dot;
end;
if tmp ≠ space ∧ tmp ≠ dot then
filling[fillword] ← filling[fillword] lor pattern;
pattern ← pattern lsh -1;
if pattern = 0 then
begin "wordbound"
pattern←'400000000000;
fillword←fillword+1;
end "wordbound";
end "handleline" until reof;
if tmp = ff ∨ reof then done "thisline";
! Skip to the end of the line, and grab the lf, too;
while tmp≠cr ∧ tmp≠ff ∧ ¬reof do tmp ← input(rchan,0);
if tmp = cr then tmp ← input(rchan,0);
notblankline ← 0;
for i ← 1 til WORDS_PER do notblankline←notblankline lor filling[i];
if notblankline then
begin "aline"
! fill in the skipped blank lines;
for i ← 1 til count_bottom_line do
if glyph_width ≤ 36 then idpb(0,therebe)
else for j ← 1 til words_per do
M[placeinto←placeinto+1]←0;
data_rows ← data_rows + count_bottom_line+1;
! number of rows in all;
count_bottom_line ← 0;
seenrealine ← TRUE;
if glyph_width ≤ 36 then idpb(filling[1],therebe)
else for j ← 1 til words_per do
M[placeinto←placeinto+1]←filling[j];
end "aline"
else
if seenrealine then count_bottom_line ← count_bottom_line +1
else rows_from_top ← rows_from_top + 1;
end "thisline" until reof;
! Set up appropriate two header words, and correct points;
if words_per=1 then
begin
intfound ← (realfound ← data_rows / (36 div glyph_width));
if intfound≠realfound then word_count ←3 + intfound
else word_count ← 2 + intfound;
end
else
word_count ← data_rows * words_per + 2;
M[needmany]← (glyph_width lsh 27) lor (char lsh 18) lor word_count;
M[needmany+1]←(left_kern ash 27) lor (rows_from_top lsh 18)
lor data_rows;
if basehi then M[FT[wtable]+'203] ← basehi; ! If there was a height
above the baseline in the command line, reset that height;
if fonthieght(wtable) < data_rows + rows_from_top + count_bottom_line then
fonthieght(wtable) ← data_rows + rows_from_top + count_bottom_line;
M[FT[wtable]+char] ← (character_width lsh 18) lor
((needmany-FT[wtable]) land '777777); ! Note -- distance may be neg;
TOP ← needmany + word_count; ! Return unused space;
goto CONTINUANCE;
ERRATA: begin "error"
! Found and error. Say so, return unused storage, and go to the next character;
tpri(<"Unable to find"&pname(char)>);
TOP ← TOP - howlong[char];
! Return the memory to free storage;
continue; ! next char;
end "error";
CONTINUANCE:;
end "eachcharacter";
release(rchan);
tpri(<CRLF&"Star/dot reading of "&askedfor&" completed.">);
return(0);
end "s2l";
! Change the font's characteristics -- the F command;
simp PROC FONTCHANGE(integer array M;integer thisfont);
begin "cv"
string took,all;
integer idull,newval;
if FT[thisfont]<0 then
begin tpri(<"Font "&cvs(thisfont)&" is not defined">);return;end;
tpri("Setting FONT characteristics.");
newval ← askabout("Height",M[FT[thisfont]+'201]);
M[FT[thisfont]+'201] ← newval;
newval ← askabout("Height above baseline",M[FT[thisfont]+'203]);
M[FT[thisfont]+'203] ← newval;
tpri("Font description:");
for idull← FT[thisfont]+'240 til FT[thisfont]+'377 do
begin
outstr(cvastr(M[idull]));
if M[idull]=0 then done;
end;
outstr(crlf&"Do you want to write a new description?");
took ← inchwl;
if took land '137 = "Y" then
begin
tpri("End input with a null line.");
tpri("New description?");
took ← all ← null;
do begin took ← inchwl;all ← all&took&crlf; end until took=null;
for idull ← 1 step 5 until 479 do
M[FT[thisfont]+'240+idull div 5]←cvasc(all[idull for 5]);
end;
end "cv";
! Play with characters - the C command: CHAREDIT;
integer proc CHAREDIT(integer array M;integer reent(0));
begin "ce"
string took;
integer itsat,itsval,base,whichchar,table,cmd,charstarts;
helphim(FALSE);
outstr("Character:");
took ← inchwl;
while took do
begin "wc"
whichchar ← lop(took);
if whichchar="#" ∧ took ∧ digit(took) then
whichchar ← octscan(took);
if took="'" then table←1 else
if took="""" then table←2 else
table←0;
base←FT[table]+whichchar;
charstarts ← ((M[base] lsh 18) ash -18) + FT [table];
if M[base] then
do begin "cmds"
outstr(">");
took ← inchwl;
cmd ← took land '137;
if cmd="D" then begin M[base]←0;done "cmds"; end
else
if cmd="K" then
begin
itsat ← ((M[base] lsh 18)ash -18) + FT[table] + 1;
itsval ← askabout("Left kern",M[itsat] ash -27);
M[itsat]←(M[itsat] land '777777777) lor
(itsval lsh 27);
end
else
if cmd="W" then
begin
itsval←askabout("Character width",
M[base] lsh -18);
if (M[charstarts] lsh -27) = 0 then
M[charstarts] ← M[charstarts] lor ((M[base] lsh -18) lsh 27);
M[base] ←
(M[base] land '777777) lor
(itsval lsh 18);
end
else
if cmd then outstr("Huh?");
end "cmds" until ¬took
else
outstr(pname(whichchar)&" not defined"&crlf);
outstr("Character:");
took ← inchwl;
end "wc"
end "ce";
! save the state of the computation: SAVETHEWORLD;
integer proc savetheworld(integer array M;string onwhat;integer reenter);
begin "stw"
own boolean restorer;
boolean mychannel;
string hesays;
integer tmp,size;
if ¬reenter then
begin "getmefile"
if onwhat ="←" then begin tmp←lop(onwhat); restorer ← 1 end else
if onwhat ="→" then begin tmp←lop(onwhat); restorer ← 0 end else
begin "nosay"
outstr("Save (S) or Restore (R)?");
hesays ← inchwl;
if(hesays land '137)= "R" then restorer←1 else restorer←0;
end "nosay";
mychannel←getmeoneof(onwhat,"TMP",tmp,tmp,tmp,'10,19*restorer,
19-19*restorer);
if mychannel < 0 then return(0);
end "getmefile"
else
mychannel ← reenter - 1;
if restorer then
begin "restoretheworld"
if ¬reenter then size ← wordin(mychannel);
if size > msize then return(err lor mychannel+1);
arryin(mychannel,ft[0],3);
arryin(mychannel,m[0],size);
top ← size + 1;
tpri("Restoration completed");
end "restoretheworld"
else
begin "saveit"
wordout(mychannel,top-1);
arryout(mychannel,ft[0],3);
arryout(mychannel,m[0],top-1);
tpri("Backup completed");
end "saveit";
release(mychannel);
return(0);
end "stw";
INTEGER PROC THEWORLD(INTEGER MEMSIZE);
BEGIN "THEWORLD"
INTEGER ARRAY M[0:MEMSIZE]; ! Main memory for hacker;
integer please,tmp,response;
string askfor;
MSIZE ← MEMSIZE;
define !!(l) = ⊂ ["l" land '37] ⊃;
while true do
begin "mainloop"
if ¬restarter then
begin "getnext"
! do begin outstr("*");
! askfor ← inchwl end until askfor≠null;
do begin
outstr("*");
askfor ← inchwl ;
if (_skip_ land '600) ∧ ((_skip_ land '177)≠cr) ∧ (_skip_ land '177)
then askfor ←askfor & (_skip_ land '177);
end until askfor≠null;
restarter ← (lop(askfor) land '37);
if askfor="""" then
begin
worldmode←2;
tmp ← lop(askfor);
end
else
if askfor="'" then
begin
worldmode←1;
tmp ← lop(askfor);
end
else
worldmode ← 0;
end "getnext"
else
gettemps(M);
while askfor=" " do tmp ← lop(askfor);
case restarter of
begin "casey"
!!(H) helphim;
!!(←) helphim;
!!(A) begin "A" ! Character assignments;
response←assignchar(M,worldmode,askfor,reenterer);
if response=ERR then
begin
reenterer ← 1;
return(restarter);
end;
end "A";
!!(B) ifc debug thenc
begin cleardisplay;BAIL end
elsec
tpri(<"Sorry, no bail">)
endc;
!!(C) response ← CHAREDIT(M);
!!(D) delete(worldmode); ! Delete a font;
!!(E) begin cleardisplay;return(-1);end; ! Exit the program;
!!(F) fontchange(M,worldmode); ! Change height, etc;
!!(G) begin "G" ! Get a font;
response ← getfont(M,askfor,worldmode,reenterer);
if response=ERR then
begin
reenterer ← 1;
return(restarter);
end;
end "G";
!!(I) begin "I" ! Input characters from a font;
response ← ichar(M,askfor,worldmode,reenterer);
if response land ERR = ERR then
begin
reenterer ← response land '7;
return(restarter);
end;
end "I";
!!(M) response ← writegf(M,worldmode,askfor); ! Write a font;
!!(N) begin
setescape;
! Glyphs to disk;
response ← N_star(M,askfor,worldmode,"DSK");
disable(15);
end;
!!(P) response ← putfont(M,worldmode,askfor); ! Write a font;
!!(R) begin "R" ! Read stars/dots;
setescape;
response ← stars2lines(M,askfor,worldmode,reenterer);
disable(15);
if response land err = err then
begin
reenterer ← response land '777;
return(restarter);
end;
end "R";
!!(S) begin "saveme"
response←savetheworld(M,askfor,reenterer);
if response land err = err then
begin
reenterer ← response land '777;
return(restarter);
end;
end "saveme";
!!(T) begin
setescape;
! Type glyphs;
response ← writestar(M,askfor,worldmode,"TTY");
disable(15);
end;
!!(W) begin
setescape;
! Glyphs to disk;
response ← writestar(M,askfor,worldmode,"DSK");
disable(15);
end;
!!(Z) begin
setescape;
! Glyphs to disk;
response ← Z_star(M,askfor,worldmode,"DSK");
disable(15);
end;
!!(@) !!(J) !!(K) !!(L) !!(O)
!!(U) !!(V) !!(X) !!(Y) !!([) !!(\) !!(]) !!(↑)
tpri("Huh?")
end "casey";
reenterer ← 0;
restarter ← 0;
end "mainloop";
END "THEWORLD";
! Main program! ;
init;
do begin "loops"
ifound ← THEWORLD(msize);
if ifound > 0 then msize ← msize + ((willneedmany div mextra)+1)* mextra;
end "loops" until ifound = -1;
tpri("BYE. Call again soon");
end "FM"